HPAVC/HPAVC CD-ROM.iso/pc/TARCHIV.ZIP/ARC.PAS

Pascal/Delphi Source File | 1995-01-27 | 19.6 KB | 747 lines

{ ARC.TPU }

{ Andreas Schiffler, U of S, 1994 }

{ This unit contains all essential archiver routines and is made to work }
{ with files. I/O primitives can be overridden to adapt the any device.  }
{ The I/O functions are sequential and block oriented, i.e. for tape.    }

Unit Arc;

Interface

Uses Dos, Objects, Logfile, ToolBox;

Const
     Blocksize   = 32*1024;
     MagicCode   = 'rchi';
     DirItemSize = 13+3*4;

Type
     tIOMode    = (fRead,fWrite);

     PByteArray = ^TByteArray;
     TByteArray = Array[0..65527] Of Byte;

     PBlock     = ^TBlock;
     TBlock     = Array [0..(Blocksize-1)] Of Byte;

     TArchiveHeader = Record
                       Magic     : String[6];
                       Filename  : String[12];
                       Filesize  : Longint;
                       Time      : Longint;
                      End;

     TChecksum = Longint;

     PDirItem = ^TDirItem;
     TDirItem = object (TObject)
                 Filename  : String[12];
                 Filesize  : Longint;
                 Time      : Longint;
                 Position  : Longint;
                 Constructor Init (NewFilename : String;
                                   NewFilesize : Longint;
                                   NewTime     : Longint;
                                   NewPosition : Longint);
                 Procedure   Store(var S: TStream);
                 Constructor Load(var S: TStream);
                end;

     PDirCollection = ^TDirCollection;
     TDirCollection = object (TSortedCollection)
                       function Compare(Key1, Key2: Pointer): Integer; virtual;
                      end;

     PArchiver = ^TArchiver;
     TArchiver = Object
                  FileBlock     : PBlock;
                  Block         : PBlock;
                  BlockNum      : Longint;      { current block number }
                  BlockOfs      : Word;         { current pos in block }
                  ArchiveFilename   : String;
                  ArchiveName       : String[12];
                  DirectoryFilename : String[12];
                  ArchiveFile    : File;
                  IOMode         : tIOMode;
                  DirCollection  : PDirCollection;
                  Checksum       : Longint;
                  DisplayFlag    : Boolean;
                  DirectorySize  : Longint;      { set by ReadDirectory }
                  TotalSize      : Longint;
                  TotalFiles     : Longint;
                  Wordy          : Boolean;
                  LongItemFlag   : Boolean;

                  ErrorLog       : PLogfile;
                  InfoLog        : PLogfile;

                  { File-archive specifics }
                  Constructor Init (Archive : String; NewIOMode : tIOMode);
                  Destructor  Done; virtual;
                  Procedure   ErrorCheck (Where : String);
                  Procedure   ReadDirectory;
                  Procedure   WriteDirectory;
                  Procedure   EraseDirectory;

                  { Archive handling }
                  Procedure AddFiles (Wildcard : String);
                  Procedure AddFile (Item : PDirItem);
                  Procedure ExtractFiles (Wildcard : String);
                  Procedure DisplayItem(Item : PDirItem);
                  Procedure ExtractNextFile;

                  { Block primitives }
                  Procedure Put (Buffer : Pointer; Count : Word);
                  Procedure Get (Buffer : Pointer; Count : Word);

                  { I/O primitives }
                  Procedure OpenArchive; virtual;
                  Procedure CloseArchive; virtual;
                  Procedure ReadBlock; virtual;
                  Procedure WriteBlock; virtual;
                  Procedure SeekBlock (NewBlockNum : Longint); virtual;
                 End;

{ ========== }

Implementation

Const
  RDirItem : TStreamRec = (
     ObjType: 10020;
     VmtLink: Ofs(TypeOf(TDirItem)^);
     Load:    @TDirItem.Load;
     Store:   @TDirItem.Store
  );

  RDirCollection : TStreamRec = (
     ObjType: 10021;
     VmtLink: Ofs(TypeOf(TDirCollection)^);
     Load:    @TDirCollection.Load;
     Store:   @TDirCollection.Store
  );

Constructor TDirItem.Init (NewFilename : String;
                           NewFilesize : Longint;
                           NewTime     : Longint;
                           NewPosition : Longint);
Begin
 Inherited Init;
 Filename := NewFilename;
 Filesize := NewFilesize;
 Time     := NewTime;
 Position := NewPosition;
End;

Procedure TDirItem.Store(var S: TStream);
Begin
 S.Write (Filename,SizeOf(Filename));
 S.Write (Filesize,SizeOf(Filesize));
 S.Write (Time,SizeOf(Time));
 S.Write (Position,SizeOf(Position));
End;

Constructor TDirItem.Load(var S: TStream);
Begin
 inherited Init;
 S.Read (Filename,SizeOf(Filename));
 S.Read (Filesize,SizeOf(Filesize));
 S.Read (Time,SizeOf(Time));
 S.Read (Position,SizeOf(Position));
End;

Function TDirCollection.Compare(Key1, Key2: Pointer): Integer;
Begin
 If PDirItem(Key1)^.Filename<PDirItem(Key2)^.Filename Then
   Compare := -1
 Else If PDirItem(Key1)^.Filename>PDirItem(Key2)^.Filename Then
   Compare := 1
 Else
   Compare := 0;
End;

Function ParseDosError : String;
Var
 S,SS: String;
Begin
 Case DosError Of
   2:  S:='File not found';
   3:  S:='Path not found';
   5:  S:='Access denied';
   6:  S:='Invalid handle';
   8:  S:='Not enough memory';
  10:  S:='Invalid environment';
  11:  S:='Invalid format';
  18:  S:='No more files';
 Else
  S:='Unknown';
 End;
 Str (DosError:2,SS);
 ParseDosError :='DOS error #'+SS+': '+S;
 DosError := 0;
End;

Function ParseIOResult(I:Integer) : String;
Var
 S,SS : String;
Begin
 Case I of
  100: S:='Disk read error';
  101: S:='Disk write error';
  102: S:='File not assigned';
  103: S:='File not open';
  104: S:='File not open for input';
  105: S:='File not open for output';
  106: S:='Invalid numeric format';
  150: S:='Disk is write protected';
  151: S:='Unknown unit';
  152: S:='Drive not ready';
  153: S:='Unknown command';
  154: S:='CRC error in data';
  155: S:='Bad drive request structure length';
  156: S:='Disk seek error';
  157: S:='Unknown media type';
  158: S:='Sector not found';
  159: S:='Printer out of paper';
  160: S:='Device write fault';
  161: S:='Device read fault';
  162: S:='Hardware failure';
 Else
  S:='Unknown';
 End;
 Str(I:3,SS);
 ParseIOResult := 'IOError #'+SS+': '+S;
End;

{ Sum buffer to form a checksum }
Function CRC (Var CRCBlock : TBlock; Count : Word) : Word;
Begin
 Asm
    PUSH DS
    LDS SI, CRCBlock { Source        DS:SI }
    MOV CX, Count    { Count }
    MOV AH, 0
    MOV BX, 0
    CLD              { forward }
    @TheLoop:
     LODSB
     ADD BX,AX
    Loop @TheLoop
    MOV @Result,BX
    POP DS
 End;
End;

Procedure TArchiver.ErrorCheck (Where : String);
Var
 I : Integer;
Begin
 I := IOResult;
 If I<>0 Then ErrorLog^.Writelog('['+Where+'] '+ParseIOResult(I));
 If DosError<>0 Then ErrorLog^.Writelog('['+Where+'] '+ParseDosError);
End;

Constructor TArchiver.Init (Archive : String; NewIOMode : tIOMode);
Var
  Dir      : DirStr;
  Name     : NameStr;
  Ext      : ExtStr;
Begin
 { Parameters }
 IOMode := NewIOMode;
 DisplayFlag := False;
 TotalSize := 0;
 TotalFiles := 0;
 Wordy := False;
 LongItemFlag := True;
 ArchiveFilename := FExpand(Archive);
 FSplit (ArchiveFilename,Dir,Name,Ext);
 ArchiveName := Name+Ext;
 DirectoryFilename := '#'+Copy(Name,1,7)+'.DIR';
 { Logfiles }
 New (ErrorLog,Init('Error.Log'));
 New (InfoLog,Init(''));
 { Data storage }
 New (Block);
 If Block=NIL Then Begin
  ErrorLog^.Writelog ('Allocation of write block: Out of memory');
  Fail;
 End;
 New (FileBlock);
 If FileBlock=NIL Then Begin
  ErrorLog^.Writelog ('Allocation of read block: Out of memory');
  Fail;
 End;
 FillChar (Block^,SizeOf(TBlock),0);
 FillChar (FileBlock^,SizeOf(TBlock),0);
 New (DirCollection,Init(100,100));
 If DirCollection=NIL Then Begin
  ErrorLog^.Writelog ('Allocation of directory: Out of memory');
  Fail;
 End;
 { Open }
 OpenArchive;
End;

Procedure TArchiver.ReadDirectory;
Var
  S : PBufStream;
  R : SearchRec;
Begin
 If Wordy Then InfoLog^.Writelog ('Reading temporary directory '+DirectoryFilename);
 FindFirst (DirectoryFilename,Archive,R);
 DirectorySize := R.Size+SizeOf(TArchiveHeader)+SizeOf(TChecksum);
 New (S,Init(DirectoryFilename,stOpenRead,1024));
 DirCollection^.Load (S^);
 Dispose(S,Done);
End;

Procedure TArchiver.WriteDirectory;
Var
  S : PBufStream;
Begin
 If Wordy Then InfoLog^.Writelog ('Writing temporary directory '+DirectoryFilename);
 New (S,Init(DirectoryFilename,stCreate,1024));
 DirCollection^.Store (S^);
 Dispose(S,Done);
End;

Procedure TArchiver.EraseDirectory;
Var
  F : File;
Begin
 If Wordy Then InfoLog^.Writelog ('Erasing temporary directory '+DirectoryFilename);
 {$I-}
 Assign (F,DirectoryFilename);
 {$I+}
 ErrorCheck ('Erasing directory');
 Erase (F);
End;

Destructor TArchiver.Done;
Var
 S1,S2 : String;
Begin
 Str (TotalSize,S1);
 Str (TotalFiles,S2);
 Commas (S1);
 If Wordy Then InfoLog^.Writelog ('Processed '+S1+' bytes in '+S2+' files.');
 { Close }
 CloseArchive;
 { Data }
 Dispose (Block);
 Dispose (FileBlock);
 Dispose (DirCollection,Done);
 Dispose (ErrorLog);
 Dispose (InfoLog);
 { Erase directory }
 EraseDirectory;
End;

Procedure TArchiver.AddFiles (Wildcard : String);
Var
  T        : Text;
  Filename : String[12];
  Location : Longint;
  S        : SearchRec;
  Count    : Integer;
  Item     : PDirItem;
Begin
 { Build directory }
 If Wordy Then InfoLog^.Writelog ('Building directory');
 Wildcard := Upper(Wildcard);
 If Length(Wildcard)>0 Then Begin
  If (Wildcard[1]='@') And (Length(Wildcard)>1) Then Begin
   { Load from list }
   Delete (Wildcard,1,1);
   If Wordy Then InfoLog^.Writelog ('Reading list '+Wildcard);
   Assign (T,Wildcard);
   {$I-}
   Reset (T);
   {$I+}
   ErrorCheck ('Opening list');
   {$I-}
   While Not EOF(T) Do Begin
    Readln (T,Filename);
    {$I+}
    ErrorCheck ('Reading list');
    {$I-}
    Dos.FindFirst(Filename,Archive,S);
    If ((DosError=0) AND (S.Size>0)) Then Begin
     DosError := 0;
     DirCollection^.Insert(New(PDirItem,Init(S.Name,S.Size,S.Time,0)));
    End;
   End;
   Close (T);
   {$I+}
   ErrorCheck ('Closing list');
  End Else Begin
   FindFirst(Wildcard, Archive, S);
   while DosError = 0 do begin
    If (S.Name<>ArchiveName) AND (S.Name<>DirectoryFilename) Then
     DirCollection^.Insert(New(PDirItem,Init(S.Name,S.Size,S.Time,0)));
    FindNext(S);
   end;
   DosError := 0;
  End;
  If DirCollection^.Count>0 Then Begin
   { Update locations }
   Location := 0;
   For Count := 0 To (DirCollection^.Count-1) Do Begin
    Item := PDirItem(DirCollection^.At(Count));
    Item^.Position := Location;
    Inc (Location,Item^.Filesize);
    Inc (Location,SizeOf(TArchiveHeader)+SizeOf(TChecksum));
   End;
   { Store the directory as first file in the list }
   WriteDirectory;
   Dos.FindFirst(DirectoryFilename,Archive,S);
   If DosError<>0 Then ErrorCheck('Adding directory');
   DirCollection^.Insert(New(PDirItem,Init(DirectoryFilename,S.Size,S.Time,0)));
   { Now add all files in the list to the archive }
   For Count := 0 To (DirCollection^.Count-1) Do Begin
    AddFile (PDirItem(DirCollection^.At(Count)));
   End;
  End Else
   InfoLog^.Writelog ('Nothing to do');
 End;
End;

Procedure TArchiver.AddFile (Item : PDirItem);
Var
  F           : File;
  Header      : TArchiveHeader;
  BytesLeft   : Longint;
  ToRead      : Word;
  NumRead     : Word;
  S           : String;
Begin
 { Open file }
 Assign (F,Item^.Filename);
 {$I-}
 Reset (F,1);
 {$I+}
 ErrorCheck('Opening File '+Item^.Filename);

 { Make header }
 Header.Magic    := MagicCode;
 Header.Filename := Item^.Filename;
 Header.Filesize := Item^.Filesize;
 Header.Time     := Item^.Time;
 { Counters }
 INC (TotalFiles);
 INC (TotalSize,Header.Filesize);
 { Write header }
 Put (@Header,SizeOf(Header));
 Str (Header.Filesize,S);
 Commas (S);
 InfoLog^.Writelog ('Writing '+Copy(Header.Filename+'            ',1,12)+'  '+Copy('            ',1,12-Length(S))+S+' bytes');

 { Copy file }
 Checksum := 0;
 BytesLeft := Header.Filesize;
 While BytesLeft>0 Do Begin
  If BytesLeft>Blocksize Then
   ToRead := BlockSize
  Else
   ToRead := BytesLeft;
  {$I-}
  BlockRead (F,FileBlock^,ToRead,NumRead);
  {$I+}
  ErrorCheck('Reading File');
  INC(Checksum,CRC (FileBlock^,ToRead));
  Put (FileBlock,ToRead);
  Dec (BytesLeft,ToRead);
 End;

 { Write Checksum }
 Put (@Checksum,SizeOf(Checksum));

 { Close file }
 {$I-}
 Close (F);
 {$I+}
 ErrorCheck('Closing File');
End;


Procedure TArchiver.DisplayItem(Item : PDirItem);
Var
  S1,S2       : String;
Begin
 S1 := Copy(Item^.Filename+'            ',1,12);
 If LongItemFlag Then Begin
  Str (Item^.Filesize:8,S2);
  S1 := S1+'   '+S2+'   '+TimeString(Item^.Time)+'   B';
  Str (((Item^.Position+DirectorySize) DIV Blocksize)+1,S2);
  S1 := S1+S2;
 End;
 InfoLog^.Writelog (S1);
End;

Procedure TArchiver.ExtractNextFile;
Var
  F           : File;
  Header      : TArchiveHeader;
  BytesLeft   : Longint;
  ToRead      : Word;
  NumWritten  : Word;
  NewChecksum : TChecksum;
  S1,S2       : String;
Begin
 { Read header }
 Get (@Header,SizeOf(Header));
 If (Header.Magic=MagicCode) Then Begin
  { Counters }
  INC (TotalFiles);
  INC (TotalSize,Header.Filesize);
  InfoLog^.Writelog ('Extracting '+Header.Filename);
  { Open file }
  Assign (F,Header.Filename);
  {$I-}
  Rewrite (F,1);
  {$I+}
  ErrorCheck('Creating '+Header.Filename);
  SetFTime (F,Header.Time);

  { Copy file }
  Checksum := 0;
  BytesLeft := Header.Filesize;
  While BytesLeft>0 Do Begin
   If BytesLeft>Blocksize Then
    ToRead := Blocksize
   Else
    ToRead := BytesLeft;
   Get (FileBlock,ToRead);
   INC (Checksum,CRC (FileBlock^,ToRead));
   {$I-}
   BlockWrite (F,FileBlock^,ToRead,NumWritten);
   {$I+}
   ErrorCheck('Writing File');
   Dec (BytesLeft,ToRead);
  End;

  { Check Checksum }
  Get (@NewChecksum,SizeOf(Checksum));
  If Checksum<>NewChecksum Then Begin
   Str (NewChecksum,S1);
   Str (Checksum,S2);
   ErrorLog^.Writelog ('Bad checksum: Checksum is '+S1+' instead of '+S2);
  End;

  { Close file }
  {$I-}
  Close (F);
  {$I+}
  ErrorCheck('Closing File');
 End Else
  ErrorLog^.Writelog ('Bad header: Magic-Code is '+Copy(Header.Magic,1,Length(MagicCode))+' instead of '+MagicCode);
End;

Procedure TArchiver.ExtractFiles (Wildcard : String);
Var
 T             : Text;
 Item          : PDirItem;
 Count         : Integer;
 ItemNum       : Integer;
 ItemBlock     : Longint;
 Filename      : String[12];
 Name,WName    : NameStr;
 Ext,WExt      : ExtStr;
 Filenames     : PStringCollection;
Begin
 If Length(Wildcard)>0 Then Begin
  { Get the directory from the archive }
  ExtractNextFile;
  ReadDirectory;
  { }
  Wildcard := Upper(Wildcard);
  If (Wildcard[1]='@') And (Length(Wildcard)>1) Then Begin
   { Extract from external ASCII list }
   New (Filenames,Init(20,20));
   Delete (Wildcard,1,1);
   If Wordy Then InfoLog^.Writelog ('Extracting from list '+Wildcard);
   Assign (T,Wildcard);
   {$I-}
   Reset (T);
   {$I+}
   ErrorCheck ('Opening list');
   {$I-}
   While Not EOF(T) Do Begin
    Readln (T,Filename);
    {$I+}
    ErrorCheck ('Reading list');
    Filenames^.Insert(NewStr(Upper(Filename)))
   End;
   {$I-}
   Close (T);
   {$I+}
   ErrorCheck ('Closing list');
   { Now go through list }
   If Filenames^.Count>0 Then Begin
    For Count := 0 To (Filenames^.Count-1) Do Begin
     Item^.Filename := PString(Filenames^.At(Count))^;
     If DirCollection^.Search(Item,ItemNum) Then Begin
      Item := PDirItem(DirCollection^.At(ItemNum));
      If DisplayFlag Then
       DisplayItem (Item)
      Else Begin
       { Relocate and extract }
       ItemBlock  := (Longint(Item^.Position)+Longint(DirectorySize)) DIV Longint(Blocksize);
       If ItemBlock<>BlockNum Then SeekBlock(ItemBlock);
       BlockOfs := (Longint(Item^.Position)+Longint(DirectorySize)) MOD Longint(Blocksize);
       ExtractNextFile;
      End;
     End;
    End;
    Dispose (Filenames,Done);
   End Else
    InfoLog^.Writelog ('Nothing to do');
  End Else Begin
   { Extract by matching wildcards }
   If Wordy Then InfoLog^.Writelog ('Matching files with '+Wildcard);
   If (Pos('.',Wildcard)<>0) Then Begin
    WName := Copy(Wildcard,1,Pos('.',Wildcard)-1);
    WExt := Copy(Wildcard,Pos('.',Wildcard)+1,3);
   End Else Begin
    WName := Wildcard;
    WExt := '';
   End;
   If DirCollection^.Count>0 Then Begin
    For ItemNum:=0 To (DirCollection^.Count-1) Do Begin
     Item := PDirItem(DirCollection^.At(ItemNum));
     If (Pos('.',Item^.Filename)<>0) Then Begin
      Name := Copy(Item^.Filename,1,Pos('.',Item^.Filename)-1);
      Ext := Copy(Item^.Filename,Pos('.',Item^.Filename)+1,3);
     End Else Begin
      Name := Item^.Filename;
      Ext := '';
     End;
     If WildMatch (Name,WName,Ext,WExt) Then Begin
      If DisplayFlag Then
       DisplayItem (Item)
      Else Begin
       { Relocate and extract }
       ItemBlock  := (Longint(Item^.Position)+Longint(DirectorySize)) DIV Longint(Blocksize);
       If ItemBlock<>BlockNum Then SeekBlock(ItemBlock);
       BlockOfs := (Longint(Item^.Position)+Longint(DirectorySize)) MOD Longint(Blocksize);
       ExtractNextFile;
      End;
     End;
    End;
   End;
  End;
 End Else
  InfoLog^.Writelog ('Nothing to do');
End;

{ Block primitives }

Procedure TArchiver.Put (Buffer : Pointer; Count : Word);
Var
  BlockLeft : Word;
  BufLeft   : Word;
  TransNum  : Word;
  BytesLeft : Word;
Begin
 BufLeft := Count;                      { # of bytes to transfer   }
 While BufLeft>0 Do Begin
  BytesLeft := BlockSize-BlockOfs;      { # of bytes left in block }
  TransNum := BytesLeft;
  If BufLeft<BytesLeft Then TransNum:=BufLeft; { # to transfer now }
  Move (PByteArray(Buffer)^[Count-BufLeft],Block^[BlockOfs],TransNum);
  Inc (BlockOfs,TransNum);
  Dec (BufLeft,TransNum);
  If BlockOfs=BlockSize Then WriteBlock;
 End;
End;

Procedure TArchiver.Get (Buffer : Pointer; Count : Word);
Var
  BlockLeft : Word;
  BufLeft   : Word;
  TransNum  : Word;
  BytesLeft : Word;
Begin
 BufLeft := Count;                        { # of bytes to transfer   }
 While BufLeft>0 Do Begin
  BytesLeft := BlockSize-BlockOfs;        { # of bytes left in block }
  TransNum := BufLeft;
  If BytesLeft<BufLeft Then TransNum:=BytesLeft; { # to transfer now }
  Move (Block^[BlockOfs],PByteArray(Buffer)^[Count-BufLeft],TransNum);
  Inc (BlockOfs,TransNum);
  Dec (BufLeft,TransNum);
  If BlockOfs=BlockSize Then ReadBlock;
 End;
End;

{ virtual methods }

Procedure TArchiver.ReadBlock;
Var
 Result : Word;
Begin
 {$I-}
 BlockRead (ArchiveFile,Block^,Blocksize,Result);
 {$I+}
 ErrorCheck('Reading block');
 If Result<>Blocksize Then ErrorLog^.Writelog('Could not read complete block');
 { Update counters }
 BlockOfs := 0;
 Inc (BlockNum);
End;

Procedure TArchiver.WriteBlock;
Var
 Result : Word;
Begin
 If BlockOfs<Blocksize Then FillChar(Block^[BlockOfs],Blocksize-BlockOfs,0);
 {$I-}
 BlockWrite (ArchiveFile,Block^,Blocksize,Result);
 {$I+}
 ErrorCheck('Writing block');
 If Result<>Blocksize Then ErrorLog^.Writelog('Could not write complete block');
 BlockOfs := 0;
 Inc (BlockNum);
End;

Procedure TArchiver.SeekBlock (NewBlockNum : Longint);
Var
 L,LMax : Longint;
Begin
 If NewBlockNum>BlockNum Then Begin
  LMax := NewBlockNum-BlockNum;
  For L := 1 To LMax Do ReadBlock;
 End;
End;

Procedure TArchiver.OpenArchive;
Begin
 If Wordy Then InfoLog^.Writelog ('Opening archive file '+ArchiveFilename);
 Assign (ArchiveFile,ArchiveFilename);
 {$I-}
 Case IOMode of
  fRead:  Begin BlockNum := -1; Reset (ArchiveFile,1); ReadBlock; End;
  fWrite: Begin BlockNum := 0; BlockOfs := 0; Rewrite (ArchiveFile,1); End;
 End;
 {$I+}
 ErrorCheck ('Opening archive '+ArchiveFilename);
End;

Procedure TArchiver.CloseArchive;
Begin
 If Wordy Then InfoLog^.Writelog ('Closing archive file '+ArchiveFilename);
 If (IOMode=fWrite) AND (BlockOfs<>0) Then WriteBlock;
 {$I+}
 Close (ArchiveFile);
 {$I+}
 ErrorCheck ('Closing archive');
End;

Begin
 RegisterType (RDirItem);
 RegisterType (RDirCollection);
End.